home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / t3_1 / nexttsrc.lha / nexttsources / sources / sys / frame.t < prev    next >
Text File  |  1988-02-05  |  5KB  |  128 lines
  1. (herald frame (env tsys))
  2.  
  3. ;;; Copyright (c) 1985 Yale University
  4. ;;;     Authors: N Adams, R Kelsey, D Kranz, J Philbin, J Rees.
  5. ;;; This material was developed by the T Project at the Yale University Computer 
  6. ;;; Science Department.  Permission to copy this software, to redistribute it, 
  7. ;;; and to use it for any purpose is granted, subject to the following restric-
  8. ;;; tions and understandings.
  9. ;;; 1. Any copy made of this software must include this copyright notice in full.
  10. ;;; 2. Users of this software agree to make their best efforts (a) to return
  11. ;;;    to the T Project at Yale any improvements or extensions that they make,
  12. ;;;    so that these may be included in future releases; and (b) to inform
  13. ;;;    the T Project of noteworthy uses of this software.
  14. ;;; 3. All materials developed as a consequence of the use of this software
  15. ;;;    shall duly acknowledge such use, in accordance with the usual standards
  16. ;;;    of acknowledging credit in academic research.
  17. ;;; 4. Yale has made no warrantee or representation that the operation of
  18. ;;;    this software will be error-free, and Yale is under no obligation to
  19. ;;;    provide any services, by way of maintenance, update, or otherwise.
  20. ;;; 5. In conjunction with products arising from the use of this material,
  21. ;;;    there shall be no use of the name of the Yale University nor of any
  22. ;;;    adaptation thereof in any advertising, promotional, or sales literature
  23. ;;;    without prior written consent from Yale in each case.
  24. ;;;
  25.  
  26. ;;;; stuff for hacking stack frames
  27.  
  28. ;;; Frame-previous returns frame in stack to which the given stack
  29. ;;; frame will return.  If there is no such "superior", return null.
  30.        
  31. (define (closure? obj)
  32.   (and (extend? obj)
  33.        (not (template-header? (extend-header obj)))
  34.        (extend? (extend-header obj))))
  35.  
  36. (define (frame? obj)
  37.   (and (closure? obj) (fx< (template-nargs (extend-header obj)) 0)))
  38.                            
  39. (define handle-stack-base
  40.   (object nil
  41.     ((frame-previous frame) (ignore frame) nil)
  42.     ((get-environment frame)   (ignore frame) nil)
  43.     ((frame-print-synopsis frame port) (ignore frame port) nil)
  44.     ((print-type-string self) "Stack-base")))
  45.  
  46. (define handle-magic-frame                       
  47.   (object nil
  48.     ((get-environment frame)   (ignore frame) nil)
  49.     ((frame-print-synopsis frame port) (ignore frame port) nil)
  50.     ((print-type-string self) "Dynamic-state-transition")))
  51.  
  52. (define-handler vframe
  53.   (object nil
  54.     ((frame-previous vframe) 
  55.      (make-pointer vframe (fx+ (vframe-pointer-slots vframe)
  56.                                (vframe-scratch-slots vframe))))
  57.     ((get-environment frame)   (ignore frame) nil)
  58.     ((frame-print-synopsis frame port) (ignore frame port) nil)
  59.     ((crawl-exhibit self)
  60.      (exhibit-standard-extend self 
  61.                               (vframe-pointer-slots self)
  62.                               (vframe-scratch-slots self)
  63.                               0))
  64.     ((maybe-crawl-component self command)
  65.      (cond ((and (nonnegative-fixnum? command)
  66.                  (fx< command (vframe-pointer-slots self)))
  67.             (crawl-push (extend-elt self command)))
  68.            (else nil)))
  69.     ((print-type-string self) "Stack environment")))
  70.  
  71. (define (frame-any pred frame)
  72.   (cond ((frame? frame)
  73.          (let ((prev (previous-continuation frame)))
  74.            (iterate loop1 ((frame frame))
  75.              (cond ((eq? frame prev) nil)
  76.                    (else  
  77.                     (let ((limit (frame-size frame)))
  78.                       (iterate loop2 ((i 0))
  79.                         (cond ((fx>= i limit) 
  80.                                (loop1 (frame-previous frame)))
  81.                               ((pred (extend-pointer-elt frame i)))
  82.                               (else (loop2 (fx+ i 1)))))))))))
  83.         (else nil)))
  84.          
  85. (define (frame-size thing)
  86.   (cond ((frame? thing)
  87.          (template-pointer-slots (extend-header thing)))
  88.         ((vframe? thing)
  89.          (vframe-pointer-slots thing))
  90.         (else 0)))
  91.                                          
  92. (define-operation (frame-previous frame)
  93.   (let ((frame (enforce frame? frame)))
  94.     (let ((tem (extend-header frame)))
  95.       (make-pointer frame (fx+ (template-pointer-slots tem)
  96.                                (template-scratch-slots tem))))))
  97.  
  98. (define (supreme-frame? frame)
  99.   (and (frame? frame) 
  100.        (not (template-superior-bit? (extend-header frame)))))
  101.  
  102. (define (closure-size-info closure)
  103.   (let ((tem (extend-header closure)))
  104.     (return (template-pointer-slots tem) (template-scratch-slots tem))))
  105.     
  106. (define (template-definer tem)
  107.   (let ((offset (template-definer-vcell-offset tem)))
  108.     (if offset
  109.         (vcell-id (extend-pointer-elt (template-unit tem) offset))
  110.         nil)))
  111.  
  112. (define (template-unit tem)
  113.   (let ((thing (template-enclosing-object tem)))
  114.     (xcond ((not (bytev? thing)) thing)
  115.            ((weak-table-entry code-unit-table thing)))))
  116.     
  117.  
  118. (define (template-definer-vcell-offset template)
  119.   (let ((template (if (fixnum-equal? (mref-16-u template -2) jump-absolute)
  120.                       (extend-elt template 0)
  121.                       template)))
  122.     (let ((offset (fixnum-ashr (mref-16-u template -12) 3)))
  123.       (if (fx= offset 0) 
  124.           nil
  125.           (fx- offset 1)))))
  126.             
  127.  
  128.